home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / STRUCTUR.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  3.1 KB  |  99 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; structures
  3.  
  4. (provide 'structure)
  5. (require 's-expression "s-expr")
  6. (require 'array)
  7. (require 'sequence)
  8.  
  9. ; (defstruct b-tree-node
  10. ;   data
  11. ;   (count 0)
  12. ;   left
  13. ;   right)
  14. ;
  15. ; causes
  16. ;
  17. ; (defmacro make-b-tree-node (&key data (count 0) left right)
  18. ;   `(let ((result (make-array 4)))
  19. ;      (setf (aref result 0) ,data)
  20. ;      (setf (aref result 1) ,count)
  21. ;      (setf (aref result 2) ,left)
  22. ;      (setf (aref result 3) ,right)
  23. ;      result))
  24. ; (defmacro copy-b-tree-node (node) `(copy-vector ,node))
  25. ; (defmacro b-tree-node-data (node) `(aref ,node 0))
  26. ; (defmacro b-tree-node-count (node) `(aref ,node 1))
  27. ; (defmacro b-tree-node-left (node) `(aref ,node 2))
  28. ; (defmacro b-tree-node-right (node) `(aref ,node 3))
  29. ; (defun b-tree-node-equal (n1 n2) (vector-equal n1 n2))
  30.  
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. ; defstruct 
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34.  
  35. (defmacro defstruct (structure-name &rest slots)
  36.   (let*
  37.     ((structure-name-string (symbol-name structure-name))
  38.      (slot-names (mapcar #'slot-name slots))
  39.      (big (length slots))
  40.      (comma-x (list 'comma 'x))
  41.      (result-label (gensym))
  42.  
  43.      (constructor-function-name
  44.        (intern
  45.          (concatenate 'string "MAKE-" structure-name-string)))
  46.  
  47.      (slot-initialization-setqs nil)
  48.  
  49.      (copy-function-name
  50.        (intern
  51.          (concatenate 'string "COPY-" structure-name-string)))
  52.  
  53.      (copy-function-defmacro-expression
  54.        `(defmacro ,copy-function-name (x) `(copy-vector ,comma-x)))
  55.  
  56.      (slot-access-function-names
  57.        (mapcar #'(lambda (s) (intern
  58.                                (concatenate 'string structure-name-string
  59.                                                     "-"
  60.                                                     (symbol-name s))))
  61.                slot-names))
  62.  
  63.      (slot-defining-defmacro-expressions nil)
  64.      
  65.      (equality-predicate-function-name
  66.        (intern
  67.          (concatenate 'string structure-name-string "-EQUAL")))
  68.      
  69.      (equality-predicate-defun-expression
  70.        `(defun ,equality-predicate-function-name (v1 v2)
  71.           (vector-equal v1 v2)))
  72.      
  73.      )
  74.  
  75.     (dotimes (i big)
  76.       (push `(defmacro ,(nth i slot-access-function-names) (x)
  77.                `(aref ,comma-x ,i))
  78.              slot-defining-defmacro-expressions)
  79.       (let ((comma-slot-name (list 'comma (nth i slot-names)))) 
  80.         (push `(setf (aref ,result-label ,i) ,comma-slot-name)
  81.                slot-initialization-setqs)))
  82.  
  83.     (let ((constructor-function-defmacro-expression
  84.             `(defmacro ,constructor-function-name (&key ,@slots)
  85.                `(let ((,result-label (make-array ,big)))
  86.                  ,@slot-initialization-setqs 
  87.                  ,result-label))))
  88.       `(progn
  89.          ,constructor-function-defmacro-expression
  90.          ,copy-function-defmacro-expression
  91.          ,equality-predicate-defun-expression
  92.          ,@slot-defining-defmacro-expressions))))
  93.  
  94. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95. ; slot-name 
  96. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97.  
  98. (defun slot-name (slot) (if (atom slot) slot (car slot)))
  99.